home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
pctchnqs
/
1991
/
number3
/
huffman.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-09-14
|
9KB
|
291 lines
{$M 32767,0,655360}
Program Huffman; {$R-}
{ Huffman compression routine.
Uses up to 15 bits for compression.
For Turbo Pascal 5.5
Copyright (c) 1989, Rick Gessner. }
Uses Crt;
Const
VideoMem = $B800; {set=$B000 if your screen is mono }
Type
TableType = Array[0..255] of Word;{one for each valid byte value }
BuffType = Array[1..1] of Byte; {used to pass conformant arrays}
{-----------------------------------------------------------------}
FUNCTION Bit_Count(Val: Word): Word;
Var I : Integer;
Begin
I:=0; { The purpose of this routine is to determine }
While Val>0 do { the significant number of bits required to }
Begin { represent the given value. }
Inc(I); { It will be used by Compress and Decompress }
Val:=Val Shr 1; { to determine how many bits to write to the }
end; { output buffer for each huffman code. }
Bit_Count:=I;
end; {Bit count}
{-----------------------------------------------------------------}
FUNCTION Create_Huffman_Code_Table(Var CodeTable,Index: TableType;
TheSize,Count: Word): Boolean;
{Returns false if it overruns the 15 Bit limitation}
Type
NodeRec = Record
Value: Real;
Next : Integer;
end;
Var TempVal : Real;
Start : Integer;
IncrVal,
WorkVal,
BitNum,
NodeCount,
I,Item : Word;
NodeList : Array[0..1000] of NodeRec;
PROCEDURE Combine(Node1,Node2: Integer);
Begin
Inc(NodeCount);
{ Add the node values: }
NodeList[NodeCount].Value := NodeList[Node1].Value +
NodeList[Node2].Value;
{ Point node up: }
Nodelist[Node1].Next := NodeCount*(Ord(Node1>1)*-1);
{ Set this node to top of list: }
NodeList[Node2].Next := NodeCount;
end; {Combine}
PROCEDURE Build_SubTree(NodePos: Integer; Max: Real);
Begin
Repeat
Combine(Start,Start-1); {Combine 2 successive nodes}
Dec(Start,2);
If (NodePos<>NodeCount) then
Begin
If (NodeList[NodePos].Value>NodeList[NodeCount].Value)
and (Start>=1) then
Build_SubTree(NodeCount,NodeList[NodePos].Value);
Combine(NodePos,Nodecount);
NodePos := NodeCount;
end
else
If (NodeList[NodePos].Value<=NodeList[Start].Value)
then
Begin
{ Combine current node with 1st node: }
Combine(NodePos,Start);
Dec(Start);
NodePos := NodeCount;
end;
Until (NodeList[NodeCount].Value>=Max) or (Start<1);
end; {Build substree}
Begin
FillChar(NodeList,Sizeof(NodeList),0);
Create_Huffman_Code_Table := False;
{ Here, put probability of each code in table in its }
{ correspondiong node: }
For Item:=1 to Count do
NodeList[Item].Value:=CodeTable[Index[Item]]/TheSize;
NodeCount := Count;
Start := Count;
Build_SubTree(Succ(NodeCount),1); {Make the huffman codes }
For Item:=1 to Count do
Begin
I:=Item; BitNum:=0;
TempVal := 0; WorkVal:=0; IncrVal:=1;
Repeat
If (NodeList[i].Value<>TempVal) and
(NodeList[i].value<>0)
then
Begin
If NodeList[i].Next<0 then Inc(WorkVal,IncrVal);
TempVal := NodeList[i].Value;
IncrVal := IncrVal shl 1; { Travel down the nodes, }
Inc(BitNum); { tracking the current bit }
end; { pattern until you hit a }
I:=Abs(NodeLIst[i].Next); { terminal node.}
Until NodeList[I].Next=0;
If BitNum > 15 then exit; { Jump out, were outta space }
Inc(WorkVal,IncrVal);
{ Assign this code to the current entry: }
CodeTable[Index[Item]]:=WorkVal;
end;
Create_Huffman_Code_Table := True;
end; {Create Huffman code Table}
{-----------------------------------------------------------------}
FUNCTION Create_Freq_Index(Var CodeTable,
FreqIndex: TableType) : Word;
Var
I,J,K,CodeTableCount : Integer;
Begin
FillChar(FreqIndex,SizeOf(FreqIndex),0); {Init freq. index}
CodeTableCount := 0;
{ This is really just a routine that creates an index }
{ into CodeTable: }
For I:=0 to 255 do If CodeTable[i]<>0 then
Begin
J:=1;
While (J<=CodeTableCount) and
(CodeTable[FreqIndex[j]]>CodeTable[i]) do Inc(J);
If FreqIndex[j]<>0 then
Move(FreqIndex[j],FreqIndex[j+1],
Succ(CodeTableCount-J)*SizeOf(Freqindex[1]));
FreqIndex[j]:=i;
Inc(CodeTableCount);
end;
Create_Freq_Index := CodeTableCount;
end; {Create freq index}
{-----------------------------------------------------------------}
FUNCTION Compress(Var Buffer1,Buffer2; Var CodeTable : TableType;
Var TheSize: Word): Boolean;
Var OrigBuffer : BuffType Absolute Buffer1;
NewBuff : BuffType Absolute Buffer2;
CodeTableIndex : TableType;
NewBuffBitNum,
BitNum,
OrigBuffPos,
NewBuffPos,
CodeCount,I : Word;
Begin
FillChar(CodeTable,SizeOf(CodeTable),0); {Init freq. table}
{ Build frequency table: }
For I:=1 to TheSize do Inc(CodeTable[OrigBuffer[i]]);
{ Create table index: }
CodeCount := Create_Freq_Index(CodeTable,CodeTableIndex);
If Create_Huffman_Code_Table(CodeTable,CodeTableIndex,
TheSize,CodeCount)
then {The index is no longer needed}
Begin
NewBuffPos := 1; { Notice that the code images are }
NewBuffBitNum := 0; { being written backwards. }
NewBuff[NewBuffPos]:=0;
For OrigBuffPos:=1 to TheSize do
Begin
For BitNum:=Bit_Count(CodeTable[OrigBuffer[OrigBuffPos]])
downto 1 do
Begin
NewBuff[NewBuffPos] := NewBuff[NewBuffPos] +
(((CodeTable[OrigBuffer[OrigBuffPos]]
Shr Pred(BitNum)) and 1) Shl NewBuffBitNum);
If NewBuffBitNum<7 then Inc(NewBuffBitNum) else
Begin
NewBuffBitNum:=0; Inc(NewBuffPos);
NewBuff[NewBuffPos]:=0;
end;
end;
end;
TheSize := NewBuffPos;
end else Compress:=False;
end; {Compress}
{------------------------------------------------------------------}
PROCEDURE Decompress(Var Buffer1,Buffer2; Var CodeTable: TableType;
Var Size: Word);
Var OrigBuff : BuffType absolute Buffer1;
NewBuff : BuffType absolute Buffer2;
CodeIndex : TableType;
BitNum,
BuffPos,
NextCode,
CodeCount : Word;
{ Compare Value to Huffman code}
{ table using a binary search. }
{ If no match, return 0, else }
{ return proper byte value. }
FUNCTION Find_Encoded_Val(Var Value: Word): Byte;
Var I : Integer;
Begin
Find_Encoded_Val:=0;
If Value>=CodeTable[CodeIndex[CodeCount]] then
For I:=1 to CodeCount do
If CodeTable[CodeIndex[i]]=Value then
Begin
Find_Encoded_Val:=CodeIndex[i]; exit;
end;
end; {Find_Encoded_Val}
Begin
{ Make code table index: }
CodeCount := Create_Freq_Index(CodeTable,CodeIndex);
BuffPos := 1; {Position in input buffer}
BitNum := 1; {Current bit number of current byte in input buffer}
Size := 0; {Init reported size of return buffer}
Repeat
NextCode:=0;
Inc(Size);
Repeat
NextCode:= (NextCode shl 1) + (OrigBuff[BuffPos] and 1);
OrigBuff[BuffPos]:=OrigBuff[BuffPos] shr 1;
If BitNum<8 then Inc(BitNum) else
Begin
BitNum:=1; Inc(BuffPos);
end;
NewBuff[Size]:=Find_Encoded_Val(NextCode);
Until (NewBuff[Size]<>0) or (NextCode=0);
Until NextCode=0;
end; {Decompress}
{-----------------------------------------------------------------}
PROCEDURE Test_It_Out;
Const ScreenSize = 160*20; {20 lines of the screen: char+Attr}
Var OldBuffer,
NewBuffer : Array[1..4000] of byte;
CompressionTable : TableType;
TheSize : Word;
Begin
{ Write 20 strings to screen: }
For TheSize:=1 to 20 do Writeln('Hello there: ',TheSize);
{ Grab the screen image: }
Move(Mem[VideoMem:0],OldBuffer,ScreenSize);
Writeln('This is the original image, press a key to test...');
If Readkey<>Chr(0) then ClrScr;
TheSize := ScreenSize;
{ Compress the buffer: }
Writeln('Compressing...');
If Compress(OldBuffer,NewBuffer,CompressionTable,TheSize) then
Begin
FillChar(OldBuffer,SizeOf(OldBuffer),0);
Writeln('Decompressing...');
{ Decompress buffer: }
Decompress(NewBuffer,OldBuffer,CompressionTable,TheSize);
Writeln('Done, press a key...');
If Readkey=' ' then;
ClrScr;
{ Redisplay buffer on screen: }
Move(OldBuffer,Mem[VideoMem:0],3200);
Readln
end;
end; {Test it out}
{------------------------------------------------------------------}
Begin
ClrScr;
Test_It_Out;
end. {Huffman program}